home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 January / PC Plus Super CD No55a (PCP-147A-1-99) (Disc 1) (1998).iso / linux / developers / visualtcl / windows / vtcl / lib / file.tcl < prev    next >
Encoding:
Text File  |  1998-09-13  |  8.6 KB  |  300 lines
  1. ##############################################################################
  2. # $Id: file.tcl,v 1.16 1997/10/24 01:47:40 stewart Exp $
  3. #
  4. # file.tcl - procedures to open, close and save applications
  5. #
  6. # Copyright (C) 1996-1997 Stewart Allen
  7. #
  8. # This program is free software; you can redistribute it and/or
  9. # modify it under the terms of the GNU General Public License
  10. # as published by the Free Software Foundation; either version 2
  11. # of the License, or (at your option) any later version.
  12. #
  13. # This program is distributed in the hope that it will be useful,
  14. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. # GNU General Public License for more details.
  17. #
  18. # You should have received a copy of the GNU General Public License
  19. # along with this program; if not, write to the Free Software
  20. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ##############################################################################
  23. #
  24.  
  25. proc vTcl:new {} {
  26.     global vTcl
  27.     if { [vTcl:close] == -1 } { return }
  28.     vTcl:new_widget toplevel
  29.     vTcl:setup_bind_tree .
  30.     vTcl:update_top_list
  31.     vTcl:update_var_list
  32.     vTcl:update_proc_list
  33.     set vTcl(project,name) "unknown.tcl"
  34.     wm title $vTcl(gui,main) "Visual Tcl - $vTcl(project,name)"
  35. }
  36.  
  37. proc vTcl:file_source {} {
  38.     set file [vTcl:get_file open "Source File"]
  39.     if {$file != ""} {
  40.         vTcl:source $file
  41.     }
  42. }
  43.  
  44. proc vTcl:source {file} {
  45.     global vTcl
  46.     set vTcl(sourcing) 1
  47.     set ov [uplevel #0 info vars];           vTcl:statbar 15
  48.     set op [uplevel #0 info procs];          vTcl:statbar 20
  49.     if [catch {uplevel #0 [list source $file]} err] {
  50.         vTcl:dialog "Error Sourcing Project\n$err"
  51.     }
  52.     vTcl:statbar 35
  53.     
  54.     # kc: ignore global vars like "tixSelect";
  55.     # otherwise File->Close breaks tix widgets.
  56.     set nv ""
  57.     foreach varname [uplevel #0 info vars] {
  58.         if {[vTcl:valid_varname $varname] == 1} {
  59.             lappend nv $varname
  60.         }
  61.     }
  62.     # kc: ignore global procs like "tixSelect"
  63.     set np ""
  64.     foreach procname [uplevel #0 info procs] {
  65.         if {[vTcl:ignore_procname_when_sourcing $procname] == 0} {
  66.             lappend np $procname
  67.         }
  68.     }
  69.     vTcl:list add [vTcl:diff_list $ov $nv] vTcl(vars)
  70.     vTcl:list add [vTcl:diff_list $op $np] vTcl(procs)
  71.     vTcl:statbar 45
  72.     set vTcl(tops) [vTcl:find_new_tops];     vTcl:statbar 0
  73.     set vTcl(sourcing) 0
  74. }
  75.  
  76. proc vTcl:open {{file ""}} {
  77.     global vTcl argc argv
  78.     if { [vTcl:close] == -1 } { return }
  79.     if {$file == ""} {
  80.         set file [vTcl:get_file open "Open Project"]
  81.     } else {
  82.         if ![file exists $file] {return}
  83.     }
  84.     if {$file != ""} {
  85.         set vTcl(file,mode) ""
  86.         proc exit {args} {}
  87.         proc init {argc argv} {}
  88.         proc main {argc argv} {}
  89.         vTcl:load_lib vtclib.tcl;            vTcl:statbar 10
  90.         set vTcl(tops) ""
  91.         set vTcl(vars) ""
  92.         set vTcl(procs) ""
  93.         vTcl:source $file;                   vTcl:statbar 55
  94.         vTcl:list add "init main" vTcl(procs)
  95.         vTcl:setup_bind_tree .;              vTcl:statbar 65
  96.         vTcl:update_top_list;                vTcl:statbar 75
  97.         vTcl:update_var_list;                vTcl:statbar 85
  98.         vTcl:update_proc_list;               vTcl:statbar 95
  99.         set vTcl(project,file) $file
  100.         set vTcl(project,name) [lindex [file split $file] end]
  101.         wm title .vTcl "Visual Tcl - $vTcl(project,name)"
  102.         vTcl:status "Done Loading"
  103.         vTcl:statbar 0
  104.     }
  105. }
  106.  
  107. proc vTcl:close {} {
  108.     global vTcl
  109.     if {$vTcl(change) > 0} {
  110.         switch [vTcl:dialog "Your application has unsaved changes.\nDo you wish to save?" "Yes No Cancel"] {
  111.             Yes {
  112.                 if {[vTcl:save_as] == -1} {
  113.                     return -1
  114.                 }
  115.             }
  116.             Cancel {
  117.                 return -1
  118.             }
  119.         }
  120.     }
  121.     set tops [winfo children .]
  122.     foreach i $tops {
  123.         if {$i != ".vTcl" && $i != ".__tk_filedialog"} {destroy $i}
  124.     }
  125.     set vTcl(tops) ""
  126.     vTcl:update_top_list
  127.     foreach i $vTcl(vars) {
  128.         catch {global $i; unset $i}
  129.     }
  130.     set vTcl(vars) ""
  131.     vTcl:update_var_list
  132.     foreach i $vTcl(procs) {
  133.         catch {rename $i {}}
  134.     }
  135.     proc exit {args} {}
  136.     proc init {argc argv} {}
  137.     proc main {argc argv} {}
  138.     set vTcl(procs) "init main"
  139.     vTcl:update_proc_list
  140.     set vTcl(project,file) ""
  141.     set vTcl(project,name) ""
  142.     set vTcl(w,widget) ""
  143.     set vTcl(w,save) ""
  144.     wm title $vTcl(gui,main) "Visual Tcl"
  145.     set vTcl(change) 0
  146. }
  147.  
  148. proc vTcl:save {} {
  149.     global vTcl
  150.     set vTcl(save) all
  151.     set vTcl(w,save) $vTcl(w,widget)
  152.     if {$vTcl(project,file) == ""} {
  153.         set file [vTcl:get_file save "Save Project"]
  154.         vTcl:save2 $file
  155.     } else {
  156.         vTcl:save2 $vTcl(project,file)
  157.     }
  158. }
  159.  
  160. proc vTcl:save_as {} {
  161.     global vTcl
  162.     set vTcl(save) all
  163.     set vTcl(w,save) $vTcl(w,widget)
  164.     set file [vTcl:get_file save "Save Project"]
  165.     vTcl:save2 $file
  166. }
  167.  
  168. proc vTcl:save2 {file} {
  169.     global vTcl env
  170.     if {$file == ""} {
  171.         return -1
  172.     }
  173.     vTcl:destroy_handles
  174.     vTcl:setup_bind_tree .
  175.  
  176.     set vTcl(project,name) [lindex [file split $file] end]
  177.     set vTcl(project,file) $file
  178.     wm title $vTcl(gui,main) "Visual Tcl - $vTcl(project,name)"
  179.     if {[file exists $file] == 1} {
  180.         file rename -force ${file} ${file}.bak
  181.     }
  182.     set output [open $file w]
  183.     if {[array get env PATH_TO_WISH] != ""} {
  184.         puts $output "#!$env(PATH_TO_WISH)"
  185.     }
  186.     puts $output "[subst $vTcl(head,proj)]\n"
  187.     if {$vTcl(save) == "all"} {
  188.         puts $output $vTcl(head,vars)
  189.         puts $output [vTcl:save_vars]
  190.         set body [string trim [info body init]]
  191.         puts $output $vTcl(head,procs)
  192.         puts $output "proc init \{argc argv\} \{\n$body\n\}\n"
  193.         puts $output "init \$argc \$argv\n"
  194.         puts $output [vTcl:save_procs]
  195.         puts $output $vTcl(head,gui)
  196.         puts $output [vTcl:save_tree .]
  197.         puts $output "main \$argc \$argv"
  198.     } else {
  199.         puts $output [vTcl:save_tree $vTcl(w,widget)]
  200.     }
  201.     close $output
  202.     vTcl:status "Done Saving"
  203.     set vTcl(file,mode) ""
  204.     if {$vTcl(w,save) != ""} {
  205.         if {$vTcl(w,widget) != $vTcl(w,save)} {
  206.             vTcl:active_widget $vTcl(w,save)
  207.         }
  208.         vTcl:create_handles $vTcl(w,save)
  209.     }
  210.     set vTcl(change) 0
  211. }
  212.  
  213. proc vTcl:quit {} {
  214.     global vTcl
  215.     if {[vTcl:close] == -1} {return}
  216.     if {$vTcl(quit)} {
  217.         if {[vTcl:dialog "Are you sure\nyou want to quit?" "Yes No"] == "No"} {
  218.             return
  219.         }
  220.     }
  221.     set vTcl(quit) 0
  222.     set vTcl(change) 0
  223.     vTcl:save_prefs
  224.     vTcl:exit
  225. }
  226.  
  227. proc vTcl:save_prefs {} {
  228.     global vTcl
  229.     set output ""
  230.     set showlist ""
  231.     foreach i $vTcl(windows) {
  232.         if {[winfo exists $i]} {
  233.             if {[wm state $i] == "normal"} {
  234.                 append output "set vTcl(geometry,${i}) [wm geometry $i]\n"
  235.                 lappend showlist $i
  236.             }
  237.         } else {
  238.             catch {
  239.                 append output "set vTcl(geometry,${i}) $vTcl(geometry,${i})\n"
  240.             }
  241.         }
  242.     }
  243.     append output "set vTcl(gui,showlist) \"$showlist\"\n"
  244.     foreach i [array names vTcl pr,*] {
  245.         append output "set vTcl($i) [list $vTcl($i)]\n"
  246.     }
  247.     catch {
  248.         set file [open $vTcl(CONF_FILE) w]
  249.         puts $file $output
  250.         close $file
  251.     }
  252. }
  253.  
  254. proc vTcl:find_files {base pattern} {
  255.     global vTcl
  256.     set dirs ""
  257.     set match ""
  258.     set files [lsort [glob -nocomplain [file join $base *]]]
  259.     if {$pattern == ""} {set pattern "*"}
  260.     foreach i $files {
  261.         if {[file isdir $i]} {
  262.             lappend dirs $i
  263.         } elseif {[string match $pattern $i]} {
  264.             lappend match $i
  265.         }
  266.     }
  267.     return "$dirs $match"
  268. }
  269.  
  270. proc vTcl:get_file {mode {title File} {ext .tcl}} {
  271.     global vTcl tk_version tcl_platform tcl_version tk_strictMotif
  272.     if {[string tolower $mode] == "open"} {
  273.         set vTcl(file,mode) "Open"
  274.     } else {
  275.         set vTcl(file,mode) "Save"
  276.     }
  277.     set types { {{Tcl Files} {*.tcl}}
  278.                 {{All}       {*}} }
  279.     set tk_strictMotif 0
  280.     switch $mode {
  281.         open {
  282.             set file [tk_getOpenFile -defaultextension $ext \
  283.                 -initialdir [pwd] -filetypes $types]
  284.         }
  285.         save {
  286.             set initname [file tail $vTcl(project,file)]
  287.             if {$initname == ""} {
  288.                 set initname "unknown.tcl"
  289.             }
  290.             set file [tk_getSaveFile -defaultextension $ext \
  291.                 -initialdir [pwd] -filetypes $types \
  292.                 -initialfile $initname]
  293.         }
  294.     }
  295.     set tk_strictMotif 1
  296.     catch {cd [file dirname $file]}
  297.     return $file
  298. }
  299.  
  300.